unit outp;

interface
uses common;
procedure export_params(var tx :text);
procedure export_tiling_header(var tx : text);
procedure export_tiling_body_mon(var tx :text);
procedure export_tiling_body(var tx :text);
procedure export_tiling_atoms(var tx :text) ;
procedure export_tiling(fname:mystring);
procedure export_atoms5d_body(var tx :text) ;
procedure export_atoms5d(fname: mystring);
procedure export_tiling_mon(fname:mystring);
procedure export_config(fname :mystring);
procedure export_config_fl(fname: mystring);
procedure export_config_if(Var emin:myreal; ecur,beta:myreal;ss:mystring);
procedure export_xyz_body(var tx :text);
procedure export_xyz(fname :mystring);
procedure export_xyz_ene(fname : mystring;se:rsites);
procedure export_xyz_enes(fname : mystring;se,sel:rsites);
procedure export_xyz_old(fname :mystring);
procedure export_obj_st(fname :mystring);

implementation
uses tools;

procedure export_tiling_header(var tx : text);
Var
   i,o : integer;
begin
   for i:=1 to 2 do begin
      for o:=1 to 5 do write(tx,bai[i,o]:5); writeln(tx);
   end;
   write(tx,tnodes:1,' ',multi:1,' ');
   write(tx,deconame);
   if(instances) then writeln(tx,' # read_tvl=1') else writeln(tx);
end;
procedure export_params(var tx: text);
Var
   i,j : integer;
begin
   {note: para_clean below screws MC simulations with enn tables, when done during the run, as in export_config_if -> copa.min.}
   {PARA_CLEAN;} {remove empty chem-para entries}
   writeln(tx,n_pxyz:1,'  # positional parameters');
   for i:=1 to n_pxyz do begin
      write(tx,i:2,' ',pxyz2orb[i]:2,'  ',pxyz[i]:1:14,'  ',nn_pxyz[i]:2,'  ');
      for j:=1 to nn_pxyz[i] do begin
	 write(tx,ch_pxyz[i,j]:2,' ',dpxyz[i,j]:1:14,'  ');
      end; writeln(tx);
   end;
   writeln(tx,n_obj_ori:1,'  # tiling_node -> object_center shifts');
   for i:=1 to n_obj_ori do begin
      writeln(tx,i:1,' ',ori2obj[i,1]:1,' ',ori2obj[i,2]:1,'  ',obj_ori[i,1]:1:14,' ',obj_ori[i,2]:1:14,'  ',obj_name[ori2obj[i,1]]);
   end;
end;
procedure export_tiling_body_mon(var tx	:text);
Var
   i,o : integer;
begin
   for i:=1 to tnodes do begin
      bound5(bt[i],rt[i]);
      rt[i,3]:=((i-1) div tnodes0)/multi;
      for o:=1 to 5 do write(tx,bt[i,o]:1,' ');
      if (instances) then write(tx,tvl[i]:8,tvlpo[i]:8);
      writeln(tx,fl[i]:8);
   end;
end; { export_tiling_body_mon }
procedure export_tiling_body(var tx :text);
Var
   i,o : integer;
begin
   for i:=1 to tnodes do begin
      bound5(bt[i],rt[i]);
      nu[i]:=nui(bt[i]);
      rt[i,3]:=((i-1) div tnodes0)/multi;
      for o:=1 to 5 do write(tx,bt[i,o]:1,' ');
      if (instances) then write(tx,tvl[i]:8,tvlpo[i]:8);      
      writeln(tx,nu[i]:8);
   end;
end; { export_tiling_body }
procedure export_tiling_atoms(var tx :text) ;
Var
   i,j,o,no : integer;
begin
   for i:=1 to tnodes do begin
      writeln(tx,nan[i]:1,' ',i:1,'  atoms bound to node#');
      for j:=1 to nan[i] do begin
	 for o:=1 to natomrec do write(tx,n_para[i,j,o]:2,' ');
	 write(tx,n_a[i,j,1]:1,' ',n_a[i,j,2]:1,' ');
	 if repre5 then begin
	    write(tx,'   ');
	    for o:=1 to 5 do write(tx,n_r5[i,j,o]:1:1,' ');
	 end;
	 if export_occup then begin
	    write(tx,'   ');
	    no:=0;
	    for o:=1 to nnele do if (n_oc[i,j,o]>0) then no:=no+1;
	    write(tx,no:1,'  ');
	    for o:=1 to nnele do if (n_oc[i,j,o]>0) then write(tx,ele[o]:1,' ',n_oc[i,j,o]/ntocc:1:3,' ');
	 end;
	 writeln(tx);
      end;
   end;
end; { export_tiling_atoms }
procedure export_tiling(fname:mystring);
Var
   tx : text;
   i,o : integer;
begin
   rewrite(tx,fname);
   for i:=1 to 2 do begin
      for o:=1 to 5 do write(tx,bai[i,o]:5); writeln(tx);
   end;
   write(tx,tnodes:1,' ',multi:1);
   if(instances) then writeln(tx,' # read_tvl=1') else writeln(tx);
   export_tiling_body(tx);
   close(tx);
end; { export_tiling }
procedure export_atoms5d_body(var tx :text) ;
Var
   i,j,o : integer;
   x5	 : v5;
begin
   for i:=1 to tnodes do begin
      for j:=1 to nan[i] do begin
	 for o:=1 to 5 do x5[o]:=bt[i,o]+n_r5[i,j,o];
	 for o:=1 to 5 do write(tx,x5[o]:1:1,' ');
	 writeln(tx,'   ',n_r[i,j,3]:1:4,'  ',n_a[i,j,1]:1,'  ',n_a[i,j,2]:1);
      end;
   end;
end;
procedure export_atoms5d(fname: mystring);
Var
   tx	     : text;
   i,j,o,nat : integer;
begin
   nat:=0;
   for i:=1 to tnodes do
      for j:=1 to nan[i] do nat:=nat+1;
   rewrite(tx,fname);
   for i:=1 to 2 do begin
      for o:=1 to 5 do write(tx,bai[i,o]:5); writeln(tx);
   end;
   writeln(tx,nat:1,'  # atoms_5d exported by d04');
   export_atoms5d_body(tx);
   close(tx);
end; { export_tiling }
procedure export_tiling_mon(fname:mystring);
Var
   tx : text;
   i,o : integer;
begin
   rewrite(tx,fname);
   for i:=1 to 2 do begin
      for o:=1 to 5 do write(tx,bai[i,o]:5); writeln(tx);
   end;
   writeln(tx,tnodes:1,' ',multi:1,'  # tiling_mon # exported by d04');
   export_tiling_body_mon(tx);
   close(tx);
end; { export_tiling_mon }
procedure export_config(fname: mystring);
var
   tx : text;
begin
   rewrite(tx,fname);
   export_tiling_header(tx);
   export_tiling_body(tx);
   export_params(tx);
   export_tiling_atoms(tx);
   close(tx);
end;
procedure export_config_fl(fname: mystring);
var
   tx : text;
begin
   rewrite(tx,fname);
   export_tiling_header(tx);
   export_tiling_body_mon(tx);
   export_params(tx);
   export_tiling_atoms(tx);
   close(tx);
end;
procedure export_config_if(Var emin:myreal; ecur,beta:myreal;ss:mystring);
Var
   tx : text;
   x  : myreal;
begin
   if (ecur<emin) then begin
      if (deco) then begin
	 {if repre5 then export_atoms5d('atoms_5d.min');}
	 export_config('copa.min');
	 export_xyz('xyz.min');
      end;
      export_tiling('tiling.min');
      rewrite(tx,'e.min');
      writeln(tx,beta:1:2,' ',ecur:1:6,' ',ss);
      close(tx);
      emin:=ecur;
   end;
end; { export_config_if }
procedure export_xyz_body(var tx :text);
var
   i,j,o,na : integer;
   w	    : v3;
begin
   na:=0;
   for i:=1 to tnodes do begin
      for j:=1 to nan[i] do begin na:=na+1;
	 {writeln(na:1,' ',i:1,' ',nan[i]:1,' ',j:1);}
	 for o:=1 to 3 do w[o]:=bound(n_r[i,j,o]+rt[i,o]);
	 for o:=1 to 3 do write(tx,w[o]:15:8);
	 writeln(tx,n_a[i,j,1]:10,n_a[i,j,2]:6);
      end;
   end;
end; { export_xyz_body }
procedure export_xyz(fname :mystring);
var
   i,j,o,p,natx	: integer;
   tx		: text;
   w		: v3;
begin
   if debug[10] then writeln('Exporting ',fname);
   natx:=0;
   for i:=0 to atps do nnat[i]:=0;
   rewrite(tx,fname);
   for i:=1 to 3 do begin
      for o:=1 to 3 do write(tx,' ',bl3[i,o]:12:7); writeln(tx);
   end;
   for i:=1 to tnodes do begin
      for j:=1 to nan[i] do begin
	 natx:=natx+1;
      end;
   end;
   writeln(tx,natx:1,' # sites');
   for i:=1 to tnodes do begin
      for j:=1 to nan[i] do begin
	 nnat[n_a[i,j,1]]:=nnat[n_a[i,j,1]]+1;
	 for o:=1 to 3 do w[o]:=bound(n_r[i,j,o]+rt[i,o]);
	 for o:=1 to 3 do write(tx,w[o]:15:8);
	 o:=n_a[i,j,4]; {object}
	 p:=n_a[i,j,5]; {sequential number of the object}
	 writeln(tx,n_a[i,j,1]:10,n_a[i,j,2]:6,'  ',obj_name[o],"_",p:1);
      end;
   end;
   close(tx);
   if debug[10] then writeln('Export ',fname+': ',natx:1,' sites.');
   natx:=natx-nnat[0]; {vacancies dont count}
   rewrite(tx,'chem.out');
   for i:=0 to atps do if (nnat[i]>0) then begin
      writeln(tx,i:2,nnat[i]:8,nnat[i]/natx:8:4);
   end;
   writeln(tx,'Total ',natx:1,' atoms, ',(natx+nnat[0]):1,' sites.');
   close(tx);
end; { export_xyz }
procedure export_xyz_ene(fname : mystring;se:rsites);
Var
   i,j,o,k : integer;
   natx	   : integer;
   w	   : v3;
   txt	   : text;
begin
   rewrite(txt,fname);
   for i:=1 to 3 do begin
      for j:=1 to 3 do write(txt,bl3[i,j]:12:5); writeln(txt);
   end;
   natx:=0;
   for i:=1 to tnodes do begin
      for j:=1 to nan[i] do begin
	 natx:=natx+1;
      end;
   end;
   writeln(txt,natx:1,' # sites');
   k:=0;
   for i:=1 to tnodes do begin
      for j:=1 to nan[i] do if (n_a[i,j,1]>0) then begin
	 k:=k+1;
	 {writeln('XXX ',i:1,' ',j:1,' ',k:1);}
	 para2xyz(n_para[i,j],n_a[i,j,1],1,1,w);
	 for o:=1 to 3 do w[o]:=bound(w[o]+rt[i,o]);
	 for o:=1 to 3 do write(txt,w[o]:15:8);
	 writeln(txt,n_a[i,j,1]:6,n_a[i,j,2]:6,se[k]:15:8);
      end else begin
	 para2xyz(n_para[i,j],n_a[i,j,1],1,1,w);
	 for o:=1 to 3 do w[o]:=bound(w[o]+rt[i,o]);
	 for o:=1 to 3 do write(txt,w[o]:15:8);
	 writeln(txt,n_a[i,j,1]:6,n_a[i,j,2]:6,'   0.0');
      end;
   end;
   close(txt);
end;
procedure export_xyz_enes(fname : mystring;se,sel:rsites);
Var
   i,j,o,k : integer;
   natx	   : integer;
   w	   : v3;
   txt	   : text;
begin
   rewrite(txt,fname);
   for i:=1 to 3 do begin
      for j:=1 to 3 do write(txt,bl3[i,j]:12:5); writeln(txt);
   end;
   natx:=0;
   for i:=1 to tnodes do begin
      for j:=1 to nan[i] do begin
	 natx:=natx+1;
      end;
   end;
   writeln(txt,natx:1,' # sites');
   k:=0;
   for i:=1 to tnodes do begin
      for j:=1 to nan[i] do if (n_a[i,j,1]>0) then begin
	 k:=k+1;
	 {writeln('XXX ',i:1,' ',j:1,' ',k:1);}
	 para2xyz(n_para[i,j],n_a[i,j,1],1,1,w);
	 for o:=1 to 3 do w[o]:=bound(w[o]+rt[i,o]);
	 for o:=1 to 3 do write(txt,w[o]:12:8);
	 writeln(txt,n_a[i,j,1]:4,n_a[i,j,2]:4,se[k]:12:8,sel[k]:12:8);
      end else begin
	 para2xyz(n_para[i,j],n_a[i,j,1],1,1,w);
	 for o:=1 to 3 do w[o]:=bound(w[o]+rt[i,o]);
	 for o:=1 to 3 do write(txt,w[o]:12:8);
	 writeln(txt,n_a[i,j,1]:4,n_a[i,j,2]:4,'  0.0 0.0');
      end;
   end;
   close(txt);
end;
procedure export_xyz_old(fname : mystring);
var
   i,j,o : integer;
   tx	 : text;
   w	 : v3;
begin
   rewrite(tx,fname);
   writeln(tx,bl3[1,1]:1:5,'  0.0  ',bl3[1,2]:1:5);
   writeln(tx,'0.0 ',lpar[2]:1:4,' 0.0');
   writeln(tx,bl3[2,1]:1:5,'  0.0  ',bl3[2,2]:1:5);
   for i:=1 to tnodes do begin
      for j:=1 to nan[i] do begin
	 for o:=1 to 3 do w[o]:=bound(n_r[i,j,o]+rt[i,o]);
	 write(tx,w[1]:12:7,w[3]:12:7,w[2]:12:7);
	 writeln(tx,n_a[i,j,1]:10,n_a[i,j,2]:6);
      end;
   end;
   close(tx);
   if debug[10] then writeln('Export ',fname+': ',nat:1,' atoms.');
end; { export_xyz_old }
procedure export_obj_st(fname :mystring);
var po,j,k,l,i,o : integer;
   tx		 : text;
begin
   if debug[10] then write('Export ',fname);
   for i:=1 to t_obj do begin
      obj_st[i]:=0;
      for j:=1 to t_sym do obj_st_list[i,j]:=0;
   end;
   for l:=1 to tnodes do begin
      for j:=1 to n_objmu[l] do begin
	 o:=n_objpo[l,j,1]; {object}
	 k:=n_objpo[l,j,2]; {orientation}
	 obj_st[o]:=obj_st[o]+1;
	 obj_st_list[o,k]:=obj_st_list[o,k]+1;
      end;
   end;
   rewrite(tx,fname);
   writeln(tx,tnodes:4,'  tiling_nodes');
   for i:=1 to n_obj do if (obj_st[i]>0) then begin
      write(tx,obj_st[i]:4,'  ',obj_name[i],'  ');
      {fill with spaces up to 15}
      {for j:=length(obj_name[i]) to 15 do write(tx,' ');}
      for j:=1 to obj_mu[i] do write(tx,obj_st_list[i,j]:1,' ');
      writeln(tx);
   end;
   close(tx);
   if debug[10] then writeln;
end;

end.
